home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / vm_port.t < prev    next >
Text File  |  1990-06-05  |  15KB  |  450 lines
  1. (herald vm_port
  2.         (env tsys (osys buffer)))
  3.  
  4. ;++ how to include e.g. Aegis_file.t in above? Logical names?
  5.  
  6. ;;; The VM-system I/O and file routines.
  7.  
  8. ;;; This file contains the virtual machine I/O interface.  An I/O
  9. ;;; buffer (IOB) is a system independent way to represent an open
  10. ;;; file, among other things.
  11.  
  12. ;;; Character ports with current position information.
  13. ;;; Note: tab characters count as one horizontal position.
  14.  
  15. ;++ All procedures in this file should be checking their arguments.
  16. ;++ They should also be checking the IOB-MODE to ensure that the
  17. ;++ operation is valid for that iob.
  18.  
  19. ;++ Buffers will eventually have both read and write offsets, and
  20. ;++ update mode will be available, along with seeking and telling.
  21.  
  22. ;;; End of file exception and object.
  23.  
  24. ;++(define-exception (end-of-file port)
  25. ;++  (ignore port)
  26. ;++  eof)
  27.  
  28.  
  29. (define eof
  30.   (object nil
  31.     ((print self port) (write-string port "#{End-of-file}"))))
  32.  
  33. (define-integrable (end-of-file port) (ignore port) eof)
  34.  
  35. ;;; Input
  36.  
  37. ;;; Internal used by retriever.  (This could be hand optimized (made
  38. ;;; a primop) if that became important.)
  39.  
  40. (define-recursive (VM-READ-BYTE iob)
  41.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  42.          (let ((c (bref (iob-buffer iob) (iob-offset iob))))
  43.            (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  44.            c))
  45.         (else
  46.          (if (eof? ((iob-underflow iob) iob nil))
  47.              (end-of-file iob)
  48.              (vm-read-byte iob)))))
  49.  
  50. ;;; VM-READ-CHAR need not check for closed channels.  See
  51. ;;; CLOSE-port for an explanation.  (This could be hand optimized
  52. ;;; (made a primop) if it became important.)
  53.  
  54. (define-recursive (VM-READ-CHAR iob)
  55.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  56.          (let ((c (text-elt (iob-buffer iob) (iob-offset iob))))
  57.            (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  58.            ;++ the #\newline isn't portable?
  59.            (cond ((charN= c #\newline)
  60.                   (set (iob-h iob) (fx+ (iob-h iob) 1)))
  61.                  (else
  62.                   (set (iob-v iob) (fx+ (iob-v iob) 1))
  63.                   (set (iob-prev-h iob) (iob-h iob))
  64.                   (set (iob-h iob) 0)))
  65.            c))
  66.         (else
  67.          (if (eof? ((iob-underflow iob) iob nil))
  68.              (end-of-file iob)
  69.              (vm-read-char iob)))))
  70.  
  71. (define-foreign unix_ioctl ("ioctl" (in rep/integer) (in rep/extend) 
  72.                     (in rep/extend))
  73.   ignore)
  74.  
  75. (let ((result (make-bytev 4)))
  76.   (define (VM-MAYBE-READ-CHAR iob)
  77.     (if (and (fx>= (iob-offset iob) (iob-limit iob))
  78.          (block (unix_ioctl (iob-xeno iob) FIONREAD result)
  79.             (fx= (mref-integer result 0) 0)))
  80.     '#f
  81.     (vm-read-char iob))))
  82.  
  83. ;;; Returns the last character read.  This procedure can only be
  84. ;;; called once without rereading the character.  UNREAD-CHAR cannot
  85. ;;; be called after calling PEEK-CHAR - this is a bug and should
  86. ;;; be fixed.  UNREAD-CHAR is probably more useful in writing
  87. ;;; recursive decent parsers then PEEK-CHAR (explain).  Note: it
  88. ;;; is an error (currently undetected) to unread and EOF.
  89.  
  90. (define (VM-UNREAD-CHAR iob)
  91.   (cond ((fx> (iob-offset iob) 0)
  92.          (cond ((iob-eof-flag? iob))
  93.                (else
  94.                 (set (iob-offset iob) (fx- (iob-offset iob) 1))
  95.                 (cond ((char= (text-elt (iob-buffer iob) (iob-offset iob))
  96.                               #\newline)
  97.                        (set (iob-h iob) (iob-prev-h iob))
  98.                        (set (iob-v iob) (fx- (iob-v iob) 1)))
  99.                       (else 
  100.                        (set (iob-h iob) (fx- (iob-h iob) 1)))))))
  101.         (else
  102.          ;; This could be made to work but it hardly seems worth
  103.          ;; the effort.
  104.          (non-continuable-error
  105.           "consecutive attempt to UNREAD-CHAR on ~a" iob)))
  106.    (no-value))
  107.  
  108. ;;; This procedure can be called any number of times.
  109.  
  110. (define (VM-PEEK-CHAR IOB)
  111.   (let ((val (vm-read-char iob)))
  112.     (cond ((eof? val)
  113.            (end-of-file iob))
  114.           (else
  115.            (vm-unread-char iob)
  116.            val))))
  117.  
  118. ;;; Block input
  119.  
  120. ;;; Note: VM-READ-BLOCK allows reading of zero length blocks.
  121. ;++ use vm-read-partial-block to do this.
  122. ;++ fix to use VM-READ-PARTIAL-BLOCK
  123.  
  124. (define (make-extend-locative extend offset length)
  125.   (let ((ptr (make-string 0)))
  126.     (set (extend-elt ptr 0)   extend)
  127.     (set (string-offset ptr) offset)
  128.     (set (string-length ptr) length)
  129.     ptr))
  130.  
  131. (define (old-VM-READ-BLOCK IOB EXTEND SIZE)
  132.   (let ((size (enforce nonnegative-fixnum? size)))
  133.     (iterate loop ((i 0))                         
  134.       (cond ((fx>= i  size) i)
  135.             (else
  136.              (let ((val (vm-read-byte iob)))
  137.                (cond ((eof? val)
  138.                       (if (fx> i 0) i (end-of-file iob)))
  139.                      (else
  140.                       (set (bref extend i) val)
  141.                       (loop (fx+ i 1))))))))))
  142.  
  143. ;++ doesn't handle hpos or vpos
  144. (define (vm-read-block iob extend size)
  145.   (let* ((offset
  146.           (iterate loop ((i 0))
  147.             (cond ((and (fx< i size)
  148.                         (fx< (iob-offset iob) (iob-limit iob)))
  149.                    (set (text-elt extend i)
  150.                         (text-elt (iob-buffer iob) (iob-offset iob)))
  151.                    (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  152.                    (loop (fx+ i 1)))
  153.                    (else i)))))
  154.     (if (fx< offset size) 
  155.         (%vm-read-partial-block 
  156.          iob 
  157.          (make-extend-locative extend offset (fx- size offset))))))
  158.  
  159. (define (VM-CLEAR-BUFFER iob)
  160.   (set (iob-offset iob) (iob-limit iob)))
  161.  
  162. ;++ what about vm-read-8-u, vm-read-integer, etc. and likewise
  163. ;++ vm-write-8 ...
  164.  
  165.  
  166. ;;; Output
  167.  
  168. ;;; When a channel is closed it's limit is set to -1 so the test
  169. ;;; below fails on closed channels.
  170. ;;; Note: The only way for VPOS to advance is to use NEWLINE
  171.  
  172. (define-recursive (VM-WRITE-BYTE iob b)
  173.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  174.          (set (bref (iob-buffer iob) (iob-offset iob)) b)
  175.          (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  176.          (set (iob-h iob)      (fx+ (iob-h iob) 1))
  177.          (no-value))
  178.         (else
  179.          ((iob-overflow iob) iob 1)
  180.          (vm-write-byte iob b))))
  181.  
  182. (define-recursive (VM-WRITE-CHAR iob C)
  183.   (cond ((fx< (iob-offset iob) (iob-limit iob))
  184.          (set (text-elt (iob-buffer iob) (iob-offset iob)) c)
  185.          (set (iob-offset iob) (fx+ (iob-offset iob) 1))
  186.          (set (iob-h iob)      (fx+ (iob-h iob) 1))
  187.          (no-value))
  188.         (else
  189.          ((iob-overflow iob) iob 1)
  190.          (vm-write-char iob c))))
  191.  
  192. (define (VM-WRITE-SPACE iob)
  193.   (cond ((or (fx>= (iob-h iob) (iob-wrap-column iob))
  194.              (fx>= (iob-h iob) (iob-line-length iob)))
  195.          (vm-newline iob))
  196.         (else
  197.          (vm-write-char iob #\space))))
  198.  
  199. (define (VM-WRITE-SPACES PORT N)           ;; Hack for FORMAT.
  200.   (iterate loop ((i 0))
  201.     (cond ((fx>= i n) (no-value))
  202.           (else
  203.            (vm-write-space port)
  204.            (loop (fx+ i 1))))))
  205.  
  206. (define (VM-NEWLINE iob)
  207.   ;; IOB-H must be set below IOB-INDENT before any calls to VM-WRITE-CHAR.
  208.   ;; On some systems (Apollo) %VM-NEWLINE calls VM-WRITE-CHAR
  209.   ;; Note: IOB-INDENT must be less than IOB-WRAP-COLUMN.
  210.   (set (iob-h iob) 0)
  211.   (%vm-newline iob)
  212.   (if (iob-interactive? iob) (vm-force-output iob))
  213.   (set (iob-v iob) (fx+ (iob-v iob) 1))
  214.   (iterate loop ((i 0))
  215.     (cond ((fx< i (iob-indent iob))
  216.            (vm-write-char iob #\space)
  217.            (loop (fx+ i 1)))
  218.           (else
  219.            (set (iob-h iob) i) 
  220.            (no-value)))))
  221.  
  222. (define (VM-WRITE-FIXNUM IOB N RDX)
  223.   (labels (((write-fx n)
  224.             (cond ((fxN= n 0)
  225.                    (write-fx (fx/ n rdx))
  226.                    (let ((c (digit->char (fx-abs (fx-rem n rdx)) rdx)))
  227.                      (vm-write-char iob c))))))
  228.     (cond ((fx= n 0) (vm-write-char iob #\0))
  229.           (else
  230.            (if (fx< n 0) (vm-write-char iob negative-sign-char))
  231.            (write-fx n)))))
  232.  
  233.  
  234. ;;; VM-WRITE-STRING and VM-WRITE-TEXT could be speeded up, by using
  235. ;;; MOVE-TEXT instead of VM-WRITE-CHAR.  Does it matter?
  236.  
  237. ;++ these next three can be flushed since they're handled by the
  238. ;++ default ops.
  239.  
  240. (define (VM-WRITE-STRING IOB STR)
  241.   (let ((len (string-length str)))
  242.     (iterate loop ((i 0))
  243.       (cond ((fx>= i len) (no-value))
  244.             (else
  245.              (vm-write-char iob (string-elt str i))
  246.              (loop (fx+ 1 i)))))))
  247.  
  248. (define (VM-WRITE-TEXT IOB TEXT COUNT)
  249.   (iterate loop ((i 0))
  250.     (cond ((fx>= i count) (no-value))
  251.           (else
  252.            (vm-write-char iob (text-elt text i))
  253.            (loop (fx+ 1 i))))))
  254.  
  255. (define (VM-WRITE-BLOCK IOB EXTEND OFFSET LENGTH)
  256.   (let ((loc (make-extend-locative extend offset length)))
  257.     (%vm-write-buffer iob)
  258.     (%vm-write-block iob loc)))
  259.  
  260. (define (VM-FORCE-OUTPUT IOB)
  261.   (%vm-write-buffer iob)
  262.   (if (not (iob-interactive? iob)) (%vm-force-output iob))
  263.   (no-value))
  264.  
  265. ;;; File access.
  266.  
  267. (define (OPEN-PORT FILESPEC MODESPEC)
  268.   (iterate loop ((fname filespec))
  269.     (let ((val (%vm-open-file 'open-port
  270.                               fname
  271.                               modespec
  272.                               default-buffer-size)))
  273.       (cond ((iob? val) val)
  274.             (else
  275.              (receive vals
  276.                       (error "(OPEN '~s '~s) failed - ~%~
  277.                              **~10t [VM - ~s]~%~
  278.                              **~10t Type (RET) or (RET filespec) to retry."
  279.                              fname 
  280.                              modespec 
  281.                              (local-os-error-message val))
  282.                (if (null? vals) 
  283.                    (loop filespec)
  284.                    (loop (car vals)))))))))
  285.  
  286. (define (MAYBE-OPEN-PORT FILESPEC MODESPEC)
  287.   (let ((mode (mode->iob-mode 'maybe-open-port filespec modespec)))
  288.   ;++ temp gross hack
  289.     (cond ((iob-mode? mode iob/retrieve)
  290.            (maybe-open-retrieve-file filespec))
  291.           ((iob-mode? mode iob/dump)
  292.            (maybe-open-dump-file filespec))
  293.           (else
  294.            (let ((val (%vm-open-file 'maybe-open-port
  295.                                      filespec
  296.                                      modespec
  297.                                      default-buffer-size)))
  298.              (if (iob? val) val '#f))))))
  299.     
  300. ;++ should this do an implicit close?
  301. (define (RE-OPEN-PORT! PORT MODESPEC)
  302.   (cond ((not (iob-closed? port))
  303.          (error "attempt to re-open an open file ~a" port))
  304.         ((eq? 'anonymous (iob-id port))    
  305.          (error "attempt to re-open an anonomous file ~a" port))
  306.         (else                          
  307.          (open-port port modespec)))
  308.   (no-value))
  309.  
  310. ;;; When a iob is closed it's limit is set to -1 so that it will
  311. ;;; fail the first test in VM-READ-CHAR, VM-READ-BYTE, VM-WRITE-CHAR, 
  312. ;;; and VM-WRITE-BYTE the
  313. ;;; overflow code will then generate a closed IOB error.
  314.  
  315. (define (CLOSE-PORT iob)
  316.   (let ((iob (enforce iob? iob)))
  317.     (cond ((iob-permanent? iob)
  318.            (nc-error "attempt to close a permanent port - ~a" iob))
  319.           ((iob-closed? iob)
  320.            (no-value))
  321.           (else
  322.            (if (iob-writable? iob) (%vm-write-buffer iob))
  323.            (if (iob-channel iob) (%vm-close-file iob))
  324.         ;++(set (table-entry open-port-table iob) nil)
  325.            (release-buffer-text %buffer-pool iob)
  326.            (set (iob-buffer iob) '#f)
  327.            (set (iob-mode   iob) iob/closed)
  328.            (set (iob-xeno   iob) '#f)
  329.            ;; make it fail in VM-READ-CHAR
  330.            (set (iob-limit  iob) -1)
  331.            (no-value)))))
  332.  
  333.  
  334. (define (with-open-ports-handler proc . openers)
  335.   (let ((ports '()))
  336.     (unwind-protect
  337.      (block (walk (lambda (opener) (push ports (opener)))
  338.                   ;; careful - don't use map here!
  339.                   openers)
  340.             ;; thanks to nat for the (set ports ...)
  341.             (apply proc (set ports (reverse! ports))))
  342.      (walk (lambda (port)
  343.              ;; deal with maybe-open.
  344.              (cond (port 
  345.                     (close port)
  346.                     (if (iob? port) (release-buffer port)))))
  347.            ports))))
  348.  
  349. (define (file-exists? filespec)
  350.   (let ((val nil))
  351.     (unwind-protect
  352.       (let ()
  353.         (set val (maybe-open-port filespec 'inquire))
  354.         (if val t nil))
  355.       (if val (close-port val)))))
  356.  
  357. ;;; Standard I/O ports
  358.  
  359. ;;; E.g. (READ (STANDARD-INPUT))
  360. ;;; (BIND (((TERMINAL-INPUT) FOO-port)) ...)
  361.  
  362. (define-simple-switch standard-input  input-port?)
  363. (define-simple-switch standard-output output-port?)
  364. (define-simple-switch standard-i/o    port?)
  365.  
  366. (define-simple-switch error-input     input-port?)
  367. (define-simple-switch error-output    output-port?)
  368. (define-simple-switch error-i/o       port?)
  369.  
  370. (define-simple-switch terminal-input  input-port?)
  371. (define-simple-switch terminal-output output-port?)
  372. (define-simple-switch terminal-i/o    port?)
  373.  
  374. (define-simple-switch debug-input     input-port?)
  375. (define-simple-switch debug-output    output-port?)
  376. (define-simple-switch debug-i/o       port?)
  377.  
  378. (define-simple-switch crawl-input     input-port?)
  379. (define-simple-switch crawl-output    output-port?)
  380. (define-simple-switch crawl-i/o       port?)
  381.  
  382.  
  383. (define (initialize-standard-ports)
  384.   (set (standard-input)  (create-iob 'standard-input
  385.                                      %%standard-input
  386.                                      (fx-ior iob/read
  387.                                              (fx-ior iob/interactive
  388.                                                      iob/permanent))
  389.                                      512))
  390.   (set (standard-output) (create-iob 'standard-output
  391.                                      %%standard-output
  392.                                      (fx-ior iob/write
  393.                                              (fx-ior iob/interactive
  394.                                                      iob/permanent))
  395.                                      512))
  396.   (set (standard-i/o)    (join (standard-input) (standard-output)))
  397.  
  398.   (set (error-input)     (standard-input))
  399.   (set (error-output)    (standard-output))
  400.   (set (error-i/o)       (join (error-input) (error-output)))
  401.  
  402.   (set (terminal-input)  (standard-input))
  403.   (set (terminal-output) (standard-output))
  404.   (set (terminal-i/o)    (join (terminal-input) (terminal-output)))
  405.  
  406.   (set (debug-input)     (error-input))
  407.   (set (debug-output)    (error-output))
  408.   (set (debug-i/o)       (join (debug-input) (debug-output)))
  409.  
  410.   (set (crawl-input)     (standard-input))
  411.   (set (crawl-output)    (standard-output))
  412.   (set (crawl-i/o)       (join (crawl-input) (crawl-output)))
  413.     )
  414.  
  415.  
  416. ;;; Hack for no apparent reason.
  417.  
  418. (define-constant null-port
  419.   (object nil
  420.     ((read-char self)      eof)
  421.     ((unread-char self)    (no-value))
  422.     ((write-char self ch)  (ignore ch) (no-value))
  423.     ((input-port? self)  '#t)
  424.     ((output-port? self) '#t)
  425.     ((port? self)        '#t)
  426.     ((print self port) (format port "#{Null port}"))))
  427.  
  428. ;;; GC hook: arrange to close open ports for ports to which
  429. ;;; there are no pointers.
  430.  
  431. ;(define (gc-close-unreferenced-ports)
  432. ; (walk-table open-port-table
  433. ;             (lambda (port h)
  434. ;               (cond ((not (object-unhash h))
  435. ;                      (close-port port)
  436. ;                      (gc-message "port closed: ~s~%" port))))))
  437.  
  438. ;;; If *POST-GC-AGENDA* doesn't have at least one element, then
  439. ;;; we're really losing.
  440.  
  441. ;++ why not move this stuff to gc-aux.t
  442. ;(append! *post-gc-agenda*
  443. ;         (list (cons 'gc-close-unreferenced-ports
  444. ;                     gc-close-unreferenced-ports)))
  445.  
  446.  
  447.  
  448. ;++ move this to the appropriate place someday
  449. (initialize-standard-ports)
  450.